home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / string.c < prev    next >
C/C++ Source or Header  |  1992-10-09  |  7KB  |  302 lines
  1. #include <ctype.h>
  2.  
  3. #include "scheme.h"
  4.  
  5. char Char_Map[256];
  6.  
  7. Init_String () {
  8.     register i;
  9.  
  10.     for (i = 0; i < 256; i++)
  11.     Char_Map[i] = i;
  12.     for (i = 'A'; i <= 'Z'; i++)
  13.     Char_Map[i] = tolower (i);
  14. }
  15.  
  16. Object General_Make_String (s, len, konst) char *s; {
  17.     Object str;
  18.  
  19.     str = Alloc_Object (len + sizeof (struct S_String) - 1, T_String, konst);
  20.     STRING(str)->tag = Null;
  21.     STRING(str)->size = len;
  22.     if (s)
  23.     bcopy (s, STRING(str)->data, len);
  24.     return str;
  25. }
  26.  
  27. Object Make_String (s, len) char *s; {
  28.     return General_Make_String (s, len, 0);
  29. }
  30.  
  31. Object Make_Const_String (s, len) char *s; {
  32.     return General_Make_String (s, len, 1);
  33. }
  34.  
  35. Object P_Stringp (s) Object s; {
  36.     return TYPE(s) == T_String ? True : False;
  37. }
  38.  
  39. Object P_Make_String (argc, argv) Object *argv; {
  40.     register len, c = ' ';
  41.     Object str;
  42.     register char *p;
  43.  
  44.     if ((len = Get_Integer (argv[0])) < 0)
  45.     Range_Error (argv[0]);
  46.     if (argc == 2) {
  47.     Check_Type (argv[1], T_Character);
  48.     c = CHAR(argv[1]);
  49.     }
  50.     str = Make_String ((char *)0, len);
  51.     for (p = STRING(str)->data; len; len--) *p++ = c;
  52.     return str;
  53. }
  54.  
  55. Object P_String (argc, argv) Object *argv; {
  56.     Object str;
  57.     register i;
  58.  
  59.     str = Make_String ((char *)0, argc);
  60.     for (i = 0; i < argc; i++) {
  61.     Check_Type (argv[i], T_Character);
  62.     STRING(str)->data[i] = CHAR(argv[i]);
  63.     }
  64.     return str;
  65. }
  66.  
  67. Object P_String_To_Number (argc, argv) Object *argv; {
  68.     Object ret;
  69.     char *b;
  70.     register struct S_String *p;
  71.     int radix = 10;
  72.     Alloca_Begin;
  73.  
  74.     Check_Type (argv[0], T_String);
  75.     if (argc == 2) {
  76.     radix = Get_Integer (argv[1]);
  77.     switch (radix) {
  78.     case 2: case 8: case 10: case 16:
  79.         break;
  80.     default:
  81.         Primitive_Error ("invalid radix: ~s", argv[1]);
  82.     }
  83.     }
  84.     p = STRING(argv[0]);
  85.     Alloca (b, char*, p->size+1);
  86.     bcopy (p->data, b, p->size);
  87.     b[p->size] = '\0';
  88.     ret = Parse_Number (b, radix);
  89.     Alloca_End;
  90.     return Nullp (ret) ? False : ret;
  91. }
  92.  
  93. Object P_String_Length (s) Object s; {
  94.     Check_Type (s, T_String);
  95.     return Make_Integer (STRING(s)->size);
  96. }
  97.  
  98. Object P_String_Ref (s, n) Object s, n; {
  99.     Check_Type (s, T_String);
  100.     return Make_Char (STRING(s)->data[Get_Index (n, s)]);
  101. }
  102.  
  103. Object P_String_Set (s, n, new) Object s, n, new; {
  104.     register i, old;
  105.  
  106.     Check_Type (s, T_String);
  107.     Check_Mutable (s);
  108.     Check_Type (new, T_Character);
  109.     old = STRING(s)->data[i = Get_Index (n, s)];
  110.     STRING(s)->data[i] = CHAR(new);
  111.     return Make_Char (old);
  112. }
  113.  
  114. Object P_Substring (s, a, b) Object s, a, b; {
  115.     register i, j;
  116.  
  117.     Check_Type (s, T_String);
  118.     if ((i = Get_Integer (a)) < 0 || i > STRING(s)->size)
  119.     Range_Error (a);
  120.     if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
  121.     Range_Error (b);
  122.     if (i > j)
  123.     Primitive_Error ("`end' less than `start'");
  124.     return Make_String (&STRING(s)->data[i], j-i);
  125. }
  126.  
  127. Object P_String_Copy (s) Object s; {
  128.     Check_Type (s, T_String);
  129.     return Make_String (STRING(s)->data, STRING(s)->size);
  130. }
  131.  
  132. Object P_String_Append (argc, argv) Object *argv; {
  133.     register i, len;
  134.     Object s, str;
  135.  
  136.     for (len = i = 0; i < argc; i++) {
  137.     Check_Type (argv[i], T_String);
  138.     len += STRING(argv[i])->size;
  139.     }
  140.     str = Make_String ((char *)0, len);
  141.     for (len = i = 0; i < argc; i++) {
  142.     s = argv[i];
  143.     bcopy (STRING(s)->data, &STRING(str)->data[len], STRING(s)->size);
  144.     len += STRING(s)->size;
  145.     }
  146.     return str;
  147. }
  148.  
  149. Object P_List_To_String (list) Object list; {
  150.     Object str, len;
  151.     register i;
  152.     GC_Node;
  153.  
  154.     GC_Link (list);
  155.     len = P_Length (list);
  156.     str = Make_String ((char *)0, FIXNUM(len));
  157.     for (i = 0; i < FIXNUM(len); i++, list = Cdr (list)) {
  158.     Check_Type (Car (list), T_Character);
  159.     STRING(str)->data[i] = CHAR(Car (list));
  160.     }
  161.     GC_Unlink;
  162.     return str;
  163. }
  164.  
  165. Object P_String_To_List (s) Object s; {
  166.     register i;
  167.     Object list, tail, cell;
  168.     GC_Node3;
  169.  
  170.     Check_Type (s, T_String);
  171.     list = tail = Null;
  172.     GC_Link3 (s, list, tail);
  173.     for (i = 0; i < STRING(s)->size; i++, tail = cell) {
  174.     cell = Cons (Make_Char (STRING(s)->data[i]), Null);
  175.     if (Nullp (list))
  176.         list = cell;
  177.     else
  178.         (void)P_Setcdr (tail, cell);
  179.     }
  180.     GC_Unlink;
  181.     return list;
  182. }
  183.  
  184. Object P_Substring_Fill (s, a, b, c) Object s, a, b, c; {
  185.     register i, j;
  186.  
  187.     Check_Type (s, T_String);
  188.     Check_Mutable (s);
  189.     Check_Type (c, T_Character);
  190.     i = Get_Index (a, s);
  191.     if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
  192.     Range_Error (b);
  193.     if (i > j)
  194.     Primitive_Error ("`end' less than `start'");
  195.     while (i < j)
  196.     STRING(s)->data[i++] = CHAR(c);
  197.     return s;
  198. }
  199.  
  200. Object P_String_Fill (s, c) Object s, c; {
  201.     Object ret;
  202.     GC_Node2;
  203.  
  204.     Check_Type (s, T_String);
  205.     Check_Mutable (s);
  206.     GC_Link2 (s, c);
  207.     ret = P_Substring_Fill (s, Make_Fixnum (0), 
  208.     Make_Integer (STRING(s)->size), c);
  209.     GC_Unlink;
  210.     return ret;
  211. }
  212.  
  213. Object General_Substringp (s1, s2, ci) Object s1, s2; register ci; {
  214.     register n, l1, l2;
  215.     register char *p1, *p2, *p3, *map;
  216.  
  217.     Check_Type (s1, T_String);
  218.     Check_Type (s2, T_String);
  219.     l1 = STRING(s1)->size;
  220.     l2 = STRING(s2)->size;
  221.     map = Char_Map;
  222.     for (p2 = STRING(s2)->data; l2 >= l1; p2++, l2--) {
  223.     for (p1 = STRING(s1)->data, p3 = p2, n = l1; n; n--, p1++, p3++) {
  224.         if (ci) {
  225.         if (map[*p1] != map[*p3]) goto fail;
  226.         } else
  227.         if (*p1 != *p3) goto fail;
  228.     }
  229.     return Make_Integer (STRING(s2)->size - l2);
  230. fail:   ;
  231.     }
  232.     return False;
  233. }
  234.  
  235. Object P_Substringp (s1, s2) Object s1, s2; {
  236.     return General_Substringp (s1, s2, 0);
  237. }
  238.  
  239. Object P_CI_Substringp (s1, s2) Object s1, s2; {
  240.     return General_Substringp (s1, s2, 1);
  241. }
  242.  
  243. General_Strcmp (s1, s2, ci) Object s1, s2; register ci; {
  244.     register n, l1, l2;
  245.     register char *p1, *p2, *map;
  246.  
  247.     Check_Type (s1, T_String);
  248.     Check_Type (s2, T_String);
  249.     l1 = STRING(s1)->size; l2 = STRING(s2)->size;
  250.     n = l1 > l2 ? l2 : l1;
  251.     p1 = STRING(s1)->data; p2 = STRING(s2)->data;
  252.     for (map = Char_Map; --n >= 0; p1++, p2++) {
  253.     if (ci) {
  254.         if (map[*p1] != map[*p2]) break;
  255.     } else
  256.         if (*p1 != *p2) break;
  257.     }
  258.     if (n < 0)
  259.     return l1 - l2;
  260.     return ci ? map[*p1] - map[*p2] : *p1 - *p2;
  261. }
  262.  
  263. Object P_Str_Eq (s1, s2) Object s1, s2; {
  264.     return General_Strcmp (s1, s2, 0) ? False : True;
  265. }
  266.  
  267. Object P_Str_Less (s1, s2) Object s1, s2; {
  268.     return General_Strcmp (s1, s2, 0) < 0 ? True : False;
  269. }
  270.  
  271. Object P_Str_Greater (s1, s2) Object s1, s2; {
  272.     return General_Strcmp (s1, s2, 0) > 0 ? True : False;
  273. }
  274.  
  275. Object P_Str_Eq_Less (s1, s2) Object s1, s2; {
  276.     return General_Strcmp (s1, s2, 0) <= 0 ? True : False;
  277. }
  278.  
  279. Object P_Str_Eq_Greater (s1, s2) Object s1, s2; {
  280.     return General_Strcmp (s1, s2, 0) >= 0 ? True : False;
  281. }
  282.  
  283. Object P_Str_CI_Eq (s1, s2) Object s1, s2; {
  284.     return General_Strcmp (s1, s2, 1) ? False : True;
  285. }
  286.  
  287. Object P_Str_CI_Less (s1, s2) Object s1, s2; {
  288.     return General_Strcmp (s1, s2, 1) < 0 ? True : False;
  289. }
  290.  
  291. Object P_Str_CI_Greater (s1, s2) Object s1, s2; {
  292.     return General_Strcmp (s1, s2, 1) > 0 ? True : False;
  293. }
  294.  
  295. Object P_Str_CI_Eq_Less (s1, s2) Object s1, s2; {
  296.     return General_Strcmp (s1, s2, 1) <= 0 ? True : False;
  297. }
  298.  
  299. Object P_Str_CI_Eq_Greater (s1, s2) Object s1, s2; {
  300.     return General_Strcmp (s1, s2, 1) >= 0 ? True : False;
  301. }
  302.